home *** CD-ROM | disk | FTP | other *** search
/ Turnbull China Bikeride / Turnbull China Bikeride - Disc 2.iso / STUTTGART / LANG / LISP / XLISP / XLISP21S / sources / c / dldmem < prev    next >
Text File  |  1992-04-25  |  28KB  |  1,110 lines
  1. /* dldmem - xlisp dynamic memory management routines */
  2. /*      Copyright (c) 1985, by David Michael Betz
  3.         All Rights Reserved
  4.         Permission is granted for unrestricted non-commercial use       */
  5.  
  6. /* Modified memory management scheme such that array/string space is
  7.    managed here rather than using malloc/free. The advantage of this is
  8.    the array/string space gets compacted allowing better operation when
  9.    available memory is tight or virtual memory is used. XSCHEME does this,
  10.    but probably needs it more since Xscheme functions are kept as compiled
  11.    code in arrays rather than lists. */
  12.  
  13. /* When this module is used rather than xldmem (and dlimage is used rather
  14.    than xlimage) then ALLOC and EXPAND take an additional second argument
  15.    for array segment allocation size and array segments to add, respectively.
  16.    The ROOM report is changed to indicate array allocation statistics. */
  17.  
  18.  
  19. #include "xlisp.h"
  20.  
  21. /* node flags */
  22. #define MARK    0x20
  23. #define LEFT    0x40
  24.  
  25. /* macro to compute the size of a segment */
  26. #define segsize(n) (sizeof(SEGMENT)+((n)-1)*sizeof(struct node))
  27.  
  28. /* external variables */
  29. extern LVAL obarray,s_gcflag,s_gchook,s_unbound,s_debugio,true;
  30. extern LVAL xlenv,xlfenv,xldenv;
  31.  
  32. /* For vector memory management */
  33. #define vsegsize(n) (sizeof(VSEGMENT)+((n)-1)*sizeof(LVAL))
  34.  
  35. #define btow_size(n) (((unsigned)(n)+(sizeof(LVAL)-1))/(unsigned)sizeof(LVAL))
  36.  
  37. typedef struct vsegment {
  38.     struct vsegment FAR *vs_next;   /* next vector segment */
  39.     LVAL FAR *vs_free;              /* next free location in this segment */
  40.     LVAL FAR *vs_top;               /* top of segment (plus one) */
  41.     LVAL vs_data[1];            /* segment data */
  42. } VSEGMENT;
  43.  
  44. VSEGMENT FAR *vsegments;    /* list of vector segments */
  45. VSEGMENT FAR *vscurrent;    /* current vector segment */
  46. int vscount;            /* number of vector segments */
  47. LVAL FAR *vfree;            /* next free location in vector space */
  48. LVAL FAR *vtop;             /* top of vector space */
  49.  
  50.  
  51. /* variables local to xldmem.c and xlimage.c */
  52. SEGMENT FAR *segs, FAR *lastseg, FAR *fixseg, FAR *charseg;
  53. int anodes,vnodes,nsegs;
  54. long gccalls;
  55. long nnodes,nfree,total;
  56. long vsfree;
  57. LVAL fnodes;
  58.  
  59. /* forward declarations */
  60. #ifdef ANSI
  61. void NEAR compact_vector(VSEGMENT FAR *vseg);
  62. void NEAR compact(void);
  63. LVAL NEAR allocvector(int type, unsigned int size);
  64. VSEGMENT FAR* newvsegment(unsigned int n);
  65. #ifdef JMAC
  66. LVAL NEAR Newnode(int type);
  67. #else
  68. LVAL NEAR newnode(int type);
  69. #endif
  70. VOID NEAR mark(LVAL ptr);
  71. VOID NEAR sweep(void);
  72. VOID NEAR findmem(void);
  73. int  NEAR addseg(void);
  74. int  scanvmemory(unsigned int size);
  75. #else
  76. FORWARD VOID compact_vector();
  77. FORWARD VSEGMENT *newvsegment();
  78. FORWARD VOID compact();
  79. FORWARD LVAL allocvector();
  80. #ifdef JMAC
  81. FORWARD LVAL Newnode();
  82. #else
  83. FORWARD LVAL newnode();
  84. #endif
  85. FORWARD VOID mark();
  86. FORWARD VOID sweep();
  87. FORWARD VOID findmem();
  88. #endif
  89.  
  90. #ifdef JMAC
  91. LVAL _nnode = NIL;
  92. FIXTYPE _tfixed = 0;
  93. int _tint = 0;
  94.  
  95. #define newnode(type) (((_nnode = fnodes) != NIL) ? \
  96.             ((fnodes = cdr(_nnode)), \
  97.              nfree--, \
  98.              (_nnode->n_type = type), \
  99.              rplacd(_nnode,NIL), \
  100.              _nnode) \
  101.             : Newnode(type))
  102.  
  103. #endif
  104.  
  105.  
  106. /* xlminit - initialize the dynamic memory module */
  107. VOID xlminit()
  108. {
  109.     LVAL p;
  110.     int i;
  111.  
  112.     /* initialize our internal variables */
  113.     segs = lastseg = NULL;
  114.     nnodes = nfree = total = gccalls = 0L;
  115.     nsegs = 0;
  116.     anodes = NNODES;
  117.     vnodes = VSSIZE;
  118.     fnodes = NIL;
  119.  
  120.     /* initialize vector space */
  121.     vsegments = vscurrent = NULL;
  122.     vscount = 0;
  123.     vfree = vtop = NULL;
  124.  
  125.     /* allocate the fixnum segment */
  126.     if ((fixseg = newsegment(SFIXSIZE)) == NULL)
  127.         xlfatal("insufficient memory");
  128.  
  129.     /* initialize the fixnum segment */
  130.     p = &fixseg->sg_nodes[0];
  131.     for (i = SFIXMIN; i <= SFIXMAX; ++i) {
  132.         p->n_type = FIXNUM;
  133.         p->n_fixnum = i;
  134.         ++p;
  135.     }
  136.  
  137.     /* allocate the character segment */
  138.     if ((charseg = newsegment(CHARSIZE)) == NULL)
  139.         xlfatal("insufficient memory");
  140.  
  141.     /* initialize the character segment */
  142.     p = &charseg->sg_nodes[0];
  143.     for (i = CHARMIN; i <= CHARMAX; ++i) {
  144.         p->n_type = CHAR;
  145.         p->n_chcode = i;
  146.         ++p;
  147.     }
  148.  
  149.     /* initialize structures that are marked by the collector */
  150.     obarray = NULL;                 /* will be set to LVAL later */
  151.     xlenv = xlfenv = xldenv = NIL;  /* list heads, initially NIL */
  152.     s_gcflag = s_gchook = NULL;     /* will be set to lval later */
  153.  
  154.     /* allocate the evaluation stack */
  155.     xlstack = xlstktop;
  156.  
  157.     /* allocate the argument stack */
  158.     xlfp = xlsp = xlargstkbase;
  159.     *xlsp++ = NIL;
  160.  
  161.     /* we have to make a NIL symbol before continuing */
  162.     {
  163.         LVAL FAR *vdata;
  164.         p = xlmakesym("NIL");
  165.         MEMCPY(NIL, p, sizeof(struct node));    /* we point to this! */
  166.         defconstant(NIL, NIL);
  167.         p->n_type = FREE;                       /* don't collect "garbage" */
  168.         vdata = p->n_vdata;                     /* correct ptr for compress */
  169.         *--vdata = NIL;
  170. }
  171.  
  172. }
  173.  
  174. /* cons - construct a new cons node */
  175. LVAL cons(x,y)
  176.   LVAL x,y;
  177. {
  178.     LVAL nnode;
  179.  
  180.     /* get a free node */
  181.     if ((nnode = fnodes) == NIL) {
  182.         xlstkcheck(2);
  183.         xlprotect(x);
  184.         xlprotect(y);
  185.         findmem();
  186.         if ((nnode = fnodes) == NIL)
  187.             xlabort("insufficient node space");
  188.         xlpopn(2);
  189.     }
  190.  
  191.     /* unlink the node from the free list */
  192.     fnodes = cdr(nnode);
  193.     --nfree;
  194.  
  195.     /* initialize the new node */
  196.     nnode->n_type = CONS;
  197.     rplaca(nnode,x);
  198.     rplacd(nnode,y);
  199.  
  200.     /* return the new node */
  201.     return (nnode);
  202. }
  203.  
  204. /* cvstring - convert a string to a string node */
  205. LVAL cvstring(str)
  206.   char FAR *str;
  207. {
  208.     LVAL val;
  209.     val = newstring(STRLEN(str));
  210.     STRCPY(getstring(val),str);
  211.     return (val);
  212. }
  213.  
  214. /* newstring - allocate and initialize a new string */
  215. LVAL newstring(size)
  216.   unsigned size;
  217. {
  218.     LVAL val;
  219.     val = allocvector(STRING,btow_size(size+1));
  220.     val->n_strlen = size;
  221.     return (val);
  222. }
  223.  
  224. /* cvsymbol - convert a string to a symbol */
  225. LVAL cvsymbol(pname)
  226.   char *pname;
  227. {
  228.     LVAL val;
  229.     xlsave1(val);
  230.     val = allocvector(SYMBOL,SYMSIZE);
  231.     setvalue(val,s_unbound);
  232.     setfunction(val,s_unbound);
  233.     setpname(val,cvstring(pname));
  234.     xlpop();
  235.     return (val);
  236. }
  237.  
  238. /* cvsubr - convert a function to a subr or fsubr */
  239. #ifdef ANSI
  240. LVAL cvsubr(LVAL (*fcn)(void), int type, int offset)
  241. #else
  242. LVAL cvsubr(fcn,type,offset)
  243.   LVAL (*fcn)(); int type,offset;
  244. #endif
  245. {
  246.     LVAL val;
  247.     val = newnode(type);
  248.     val->n_subr = fcn;
  249.     val->n_offset = offset;
  250.     return (val);
  251. }
  252.  
  253. /* cvfile - convert a file pointer to a stream */
  254. LVAL cvfile(fp, iomode)
  255.   FILEP fp;
  256.   int iomode;
  257. {
  258.     LVAL val;
  259.     val = newnode(STREAM);
  260.     setfile(val,fp);
  261.     setsavech(val,'\0');
  262.     val->n_sflags = iomode;
  263.     val->n_cpos = 0;
  264.     return (val);
  265. }
  266.  
  267. #ifdef JMAC
  268.  
  269. /* cvfixnum - convert an integer to a fixnum node */
  270. LVAL Cvfixnum(n)
  271.   FIXTYPE n;
  272. {
  273.     LVAL val;
  274.     val = newnode(FIXNUM);
  275.     val->n_fixnum = n;
  276.     return (val);
  277. }
  278. #else
  279. /* cvfixnum - convert an integer to a fixnum node */
  280. LVAL cvfixnum(n)
  281.   FIXTYPE n;
  282. {
  283.     LVAL val;
  284.     if (n >= SFIXMIN && n <= SFIXMAX)
  285.         return (&fixseg->sg_nodes[(int)n-SFIXMIN]);
  286.     val = newnode(FIXNUM);
  287.     val->n_fixnum = n;
  288.     return (val);
  289. }
  290. #endif
  291.  
  292. #ifdef RATIOS
  293. /* cvratio - convert an integer pair to a ratio node */
  294. LVAL cvratio(num, denom)
  295. FIXTYPE num, denom;
  296. {
  297.     LVAL val;
  298.     FIXTYPE n, m, r;
  299.  
  300.     if (num == 0) return cvfixnum((FIXTYPE) 0); /* zero is int zero */
  301.     if (denom < 0) {    /* denominator must be positive */
  302.         denom = -denom;
  303.         num = -num;
  304.     }
  305.     if ((n = num) < 0) n = -n;
  306.     m = denom;  /* reduce the ratio: compute GCD */
  307.     for (;;) {
  308.         if ((r = m % n) == 0) break;
  309.         m = n;
  310.         n = r;
  311.     }
  312.     if (n != 1) {
  313.         denom /= n;
  314.         num /= n;
  315.     }
  316.     if (denom == 1) return cvfixnum(num);   /* reduced to integer */
  317.     val = newnode(RATIO);
  318.     val->n_denom = denom;
  319.     val->n_numer = num;
  320.     return (val);
  321. }
  322. #endif
  323.  
  324. /* cvflonum - convert a floating point number to a flonum node */
  325. LVAL cvflonum(n)
  326.   FLOTYPE n;
  327. {
  328.     LVAL val;
  329.     val = newnode(FLONUM);
  330.     val->n_flonum = n;
  331.     return (val);
  332. }
  333.  
  334. /* cvchar - convert an integer to a character node */
  335. #ifdef JMAC
  336. LVAL Cvchar(n)
  337.   int n;
  338. {
  339.     xlerror("character code out of range",cvfixnum((FIXTYPE)n));
  340.     return (NIL);   /* never really returns */
  341. }
  342. #else
  343. LVAL cvchar(n)
  344.   int n;
  345. {
  346. #if (CHARMIN == 0)  /* TAA  MOD eliminating a comparison */
  347.     if (((unsigned)n) <= CHARMAX)
  348. #else
  349.     if (n >= CHARMIN && n <= CHARMAX)
  350. #endif
  351.         return (&charseg->sg_nodes[n-CHARMIN]);
  352.     xlerror("character code out of range",cvfixnum((FIXTYPE)n));
  353.     return (NIL);   /* never really returns */
  354. }
  355. #endif
  356.  
  357. /* newustream - create a new unnamed stream */
  358. LVAL newustream()
  359. {
  360.     LVAL val;
  361.     val = newnode(USTREAM);
  362.     sethead(val,NIL);
  363.     settail(val,NIL);
  364.     return (val);
  365. }
  366.  
  367. /* newobject - allocate and initialize a new object */
  368. LVAL newobject(cls,size)
  369.   LVAL cls; int size;
  370. {
  371.     LVAL val;
  372.     val = allocvector(OBJECT,size+1);
  373.     setelement(val,0,cls);
  374.     return (val);
  375. }
  376.  
  377. /* newclosure - allocate and initialize a new closure */
  378. LVAL newclosure(name,type,env,fenv)
  379.   LVAL name,type,env,fenv;
  380. {
  381.     LVAL val;
  382.     val = allocvector(CLOSURE,CLOSIZE);
  383.     setname(val,name);
  384.     settype(val,type);
  385.     setenvi(val,env);
  386.     setfenv(val,fenv);
  387.     return (val);
  388. }
  389.  
  390. /* newstruct - allocate and initialize a new structure node */
  391. LVAL newstruct(type,size)
  392.  LVAL type; int size;
  393. {
  394.     LVAL val;
  395.     val = allocvector(STRUCT,size+1);
  396.     setelement(val,0,type);
  397.     return (val);
  398. }
  399.  
  400.  
  401. /* newvector - allocate and initialize a new vector */
  402. LVAL newvector(size)
  403.   unsigned size;
  404. {
  405.     return (allocvector(VECTOR,size));
  406. }
  407.  
  408.  
  409. /* getvused - get used vector space */
  410. /* also sets vsfree to free space */
  411. #ifdef ANSI
  412. static long NEAR getvused(void)
  413. #else
  414. LOCAL long getvused()
  415. #endif
  416. {
  417.     long vnu=0L;
  418.     VSEGMENT FAR *vseg;
  419.     
  420.     vsfree = 0L;
  421.     
  422.     if (vscurrent != NULL)
  423.         vscurrent->vs_free = vfree;
  424.     for (vseg = vsegments; vseg != NULL; vseg = vseg->vs_next) {
  425.         vnu += ((long)vseg->vs_free - (long)&vseg->vs_data[0])/sizeof(LVAL FAR *);
  426.         vsfree += ((long)vseg->vs_top - (long)vseg->vs_free)/sizeof(LVAL FAR *);
  427.     }
  428.     return vnu;
  429. }
  430.  
  431.  
  432. /* allocvector - allocate and initialize a new vector node */
  433. LOCAL LVAL NEAR allocvector(type,size)
  434.   int type;
  435.   unsigned size;
  436. {
  437.     LVAL val, FAR *p;
  438.     unsigned int i;
  439.  
  440.     if (size+1 > MAXVLEN) xlfail("array too large");
  441.  
  442.     xlsave1(val);
  443.     val = newnode(type);
  444.  
  445.     /* initialize the vector node */
  446.     val->n_type = type;
  447.     val->n_vsize = size;
  448.     val->n_vdata = NULL;
  449.  
  450.     /* add space for the backpointer */
  451.     ++size;
  452.     
  453.     /* make sure there's enough space */
  454.     if (((unsigned)vtop-(unsigned)vfree < size*sizeof(LVAL FAR *)) && 
  455.         !scanvmemory(size)) {
  456.         gc();   /* try cleaning up and scanning again */
  457.         getvused(); /* calculate free and used space */
  458.         if (!scanvmemory(size) || vsfree < vnodes) 
  459.             newvsegment(size);  /* no memory -- allocate segment */
  460.         if ((unsigned)vtop-(unsigned)vfree < size*sizeof(LVAL FAR *))
  461.             xlabort("insufficient vector space");
  462.     }
  463.  
  464.     /* allocate the next available block */
  465.     p = vfree;
  466.     vfree += size;
  467.     
  468.     /* store the backpointer */
  469.     *p++ = val;
  470.     val->n_vdata = p;
  471.  
  472.     /* set all the elements to NIL, except for STRINGs */
  473.     if (type != STRING) for (i = size; i > 1; --i) *p++ = NIL;
  474.  
  475.     /* return the new vector */
  476.     xlpop();
  477.     return (val);
  478. }
  479.  
  480. /* scanvmemory - look for vector segment with enough space */
  481. /* return success */
  482. int scanvmemory(size)
  483.   unsigned int size;
  484. {
  485.     VSEGMENT FAR *vseg;
  486.     if (vscurrent != NULL)
  487.         vscurrent->vs_free = vfree;
  488.     for (vseg = vsegments; vseg != NULL; vseg = vseg->vs_next)
  489.         if ((unsigned)vseg->vs_top - (unsigned)vseg->vs_free > 
  490.             size*sizeof(LVAL FAR *)) {
  491.             vfree = vseg->vs_free;
  492.             vtop = vseg->vs_top;
  493.             vscurrent = vseg;
  494.             return TRUE;
  495.         }
  496.     return FALSE;
  497. }
  498.  
  499. /* newvsegment - create a new vector segment */
  500. VSEGMENT FAR *newvsegment(n)
  501.   unsigned int n;
  502. {
  503.     VSEGMENT FAR *newseg;
  504.     long reqsize;
  505.  
  506.     if (n < vnodes) n = vnodes; /* allocate vnodes if larger than request */
  507.  
  508.  
  509.     reqsize = vsegsize((long)n);
  510.  
  511.     if ((unsigned int)reqsize != reqsize) return NULL;  /* can't do it */
  512.  
  513.     /* allocate the new segment */
  514.     if ((newseg = (VSEGMENT FAR *)MALLOC((unsigned int)reqsize)) == NULL)
  515.         return (NULL);
  516.  
  517.     if (vscurrent != NULL)
  518.         vscurrent->vs_free = vfree;
  519.  
  520.     /* initialize the new segment */
  521.     vfree = newseg->vs_free = &newseg->vs_data[0];
  522.     vtop = newseg->vs_top = newseg->vs_free + n;
  523.     newseg->vs_next = vsegments;
  524.     vscurrent = vsegments = newseg;
  525.  
  526.     /* update the statistics */
  527.     total += reqsize;
  528.     ++vscount;
  529.  
  530.     /* return the new segment */
  531.     return (newseg);
  532. }
  533.  
  534. /* newnode - allocate a new node */
  535. #ifdef JMAC
  536. LOCAL LVAL NEAR Newnode(type)
  537.   int type;
  538. {
  539.     LVAL nnode;
  540.  
  541.     /* get a free node */
  542.     findmem();
  543.     if ((nnode = fnodes) == NIL)
  544.         xlabort("insufficient node space");
  545.  
  546.     /* unlink the node from the free list */
  547.     fnodes = cdr(nnode);
  548.     nfree -= 1L;
  549.  
  550.     /* initialize the new node */
  551.     nnode->n_type = type;
  552.     rplacd(nnode,NIL);
  553.  
  554.     /* return the new node */
  555.     return (nnode);
  556. }
  557. #else
  558. LOCAL LVAL NEAR newnode(type)
  559.   int type;
  560. {
  561.     LVAL nnode;
  562.  
  563.     /* get a free node */
  564.     if ((nnode = fnodes) == NIL) {
  565.         findmem();
  566.         if ((nnode = fnodes) == NIL)
  567.             xlabort("insufficient node space");
  568.     }
  569.  
  570.     /* unlink the node from the free list */
  571.     fnodes = cdr(nnode);
  572.     nfree -= 1L;
  573.  
  574.     /* initialize the new node */
  575.     nnode->n_type = type;
  576.     rplacd(nnode,NIL);
  577.  
  578.     /* return the new node */
  579.     return (nnode);
  580. }
  581. #endif
  582.  
  583. /* findmem - find more memory by collecting then expanding */
  584. LOCAL VOID NEAR findmem()
  585. {
  586.     gc();
  587.     if (nfree < (long)anodes)
  588.         addseg();
  589. }
  590.  
  591. /* gc - garbage collect (only called here and in xlimage.c) */
  592. VOID gc()
  593. {
  594.     LVAL **p,*ap,tmp;
  595.     FRAMEP newfp;
  596.     LVAL fun;
  597.  
  598.     /* print the start of the gc message */
  599.     if (s_gcflag!=NULL && getvalue(s_gcflag) != NIL) {
  600.         /* print message on a fresh line */
  601.         xlfreshline(getvalue(s_debugio));
  602.         sprintf(buf,"[ gc: total %ld, ",nnodes);
  603.         dbgputstr(buf); /* TAA MOD -- was std output */
  604.     }
  605.  
  606.     /* mark the obarray, the argument list and the current environment */
  607.     if (obarray != NULL)
  608.         mark(obarray);
  609.     if (xlenv != NIL)
  610.         mark(xlenv);
  611.     if (xlfenv != NIL)
  612.         mark(xlfenv);
  613.     if (xldenv != NIL)
  614.         mark(xldenv);
  615.  
  616.     mark(NIL);
  617.  
  618.     /* mark the evaluation stack */
  619.     for (p = xlstack; p < xlstktop; ++p)
  620.         if ((tmp = **p) != NIL)
  621.             mark(tmp);
  622.  
  623.     /* mark the argument stack */
  624.     for (ap = xlargstkbase; ap < xlsp; ++ap)
  625.         if ((tmp = *ap) != NIL)
  626.             mark(tmp);
  627.  
  628.     /* compact vector space */
  629.     compact();
  630.  
  631.         /* sweep memory collecting all unmarked nodes */
  632.     sweep();
  633.  
  634.     NIL->n_type &= ~MARK;
  635.  
  636.  
  637.     /* count the gc call */
  638.     ++gccalls;
  639.  
  640.     /* call the *gc-hook* if necessary */
  641.     if (s_gchook != NULL && ((fun = getvalue(s_gchook)) != NIL) ) {
  642.         /* rebind hook function to NIL  TAA MOD */
  643.         tmp = xldenv;
  644.         xldbind(s_gchook,NIL);
  645.  
  646.         newfp = xlsp;
  647.         pusharg(cvfixnum((FIXTYPE)(newfp - xlfp)));
  648.         pusharg(fun);
  649.         pusharg(cvfixnum((FIXTYPE)2));
  650.         pusharg(cvfixnum((FIXTYPE)nnodes));
  651.         pusharg(cvfixnum((FIXTYPE)nfree));
  652.         xlfp = newfp;
  653.         xlapply(2);
  654.  
  655.         /* unbind the symbol TAA MOD */
  656.         xlunbind(tmp);
  657.     }
  658.  
  659.     /* print the end of the gc message */
  660.     if (s_gcflag != NULL && getvalue(s_gcflag) != NIL) {
  661.         sprintf(buf,"%ld free ]\n",nfree);
  662.         dbgputstr(buf); /* TAA MOD -- was std output */
  663.     }
  664. }
  665.  
  666. /* mark - mark all accessible nodes */
  667. LOCAL VOID NEAR mark(ptr)
  668.   LVAL ptr;
  669. {
  670.     register LVAL this,prev,tmp;
  671.     int i,n;
  672.  
  673.     /* initialize */
  674.     prev = NIL;
  675.     this = ptr;
  676.  
  677.     /* mark this list */
  678.     for (;;) {
  679.     /* descend as far as we can */
  680.     while (!(this->n_type & MARK))
  681.   
  682.         /* check cons and unnamed stream nodes */
  683.         if (((i = (this->n_type |= MARK) & TYPEFIELD) == CONS)||
  684.             (i == USTREAM)) {
  685.             if ((tmp = car(this)) != NIL) {
  686.                 this->n_type |= LEFT;
  687.                 rplaca(this,prev);
  688.             }
  689.             else if ((tmp = cdr(this)) != NIL)
  690.                 rplacd(this,prev);
  691.             else                /* both sides nil */
  692.                 break;
  693.             prev = this;            /* step down the branch */
  694.             this = tmp;
  695.         }
  696.         else {
  697.             if (((i & ARRAY) != 0) && (this->n_vdata != NULL))
  698.                 for (i = 0, n = getsize(this); i < n;)
  699.                     if ((tmp = getelement(this,i++)) != NIL)
  700.                         if ((tmp->n_type & (ARRAY|MARK)) == ARRAY ||
  701.                             tmp->n_type == CONS ||
  702.                             tmp->n_type == USTREAM)
  703.                             mark(tmp);
  704.                         else tmp->n_type |= MARK;
  705.                         break;
  706.         }
  707.  
  708.         /* backup to a point where we can continue descending */
  709.         for (;;)
  710.  
  711.             /* make sure there is a previous node */
  712.             if (prev!=NIL) {
  713.                 if (prev->n_type & LEFT) {      /* came from left side */
  714.                     prev->n_type &= ~LEFT;
  715.                     tmp = car(prev);
  716.                     rplaca(prev,this);
  717.                     if ((this = cdr(prev)) != NIL) {
  718.                         rplacd(prev,tmp);                       
  719.                         break;
  720.                     }
  721.                 }
  722.                 else {                          /* came from right side */
  723.                     tmp = cdr(prev);
  724.                     rplacd(prev,this);
  725.                 }
  726.                 this = prev;                    /* step back up the branch */
  727.                 prev = tmp;
  728.             }
  729.             /* no previous node, must be done */
  730.             else
  731.                 return;
  732.     }
  733. }
  734.  
  735. /* compact - compact vector space */
  736. LOCAL VOID NEAR compact()
  737. {
  738.     VSEGMENT FAR *vseg, FAR *vsold;
  739.  
  740.     /* store the current segment information */
  741.     if (vscurrent != NULL)
  742.         vscurrent->vs_free = vfree;
  743.  
  744.     /* compact each vector segment */
  745.     for (vseg = vsegments, vsold = (VSEGMENT FAR *)&vsegments; 
  746.          vseg != NULL; 
  747.          vsold = vseg, vseg = vseg->vs_next) {
  748.          compact_vector(vseg);
  749. #if 0
  750.          if (vseg->vs_free == &vseg->vs_data[0]) {  /* empty segment */
  751.              vsold->vs_next = vseg->vs_next;    /* unlink segment */
  752.              vscount--;                         /* adjust tallies */
  753.              total -= sizeof(VSEGMENT)-sizeof(LVAL FAR *)+
  754.                  (unsigned)vseg->vs_top - (unsigned)vseg->vs_free;
  755.              MFREE(vseg);                       /* free segment */
  756.              vseg = vsold;                      /* last becomes current */
  757.          }
  758. #endif
  759.     }
  760.  
  761.     /* make the first vector segment current */
  762.     if ((vscurrent = vsegments) != NULL) {
  763.         vfree = vscurrent->vs_free;
  764.         vtop = vscurrent->vs_top;
  765.     }
  766.  
  767.  
  768.     getvused(); /* calculate free and used space */
  769.  
  770.     /*  and free any unused segments if lots of free space (TAA MOD) */
  771.     if (vsfree > 2*(long)vnodes) {
  772.         for (vseg = vsegments, vsold = (VSEGMENT FAR *)&vsegments;
  773.             vseg != NULL;
  774.             vsold = vseg, vseg = vseg->vs_next) 
  775.             if (vseg->vs_free == &vseg->vs_data[0]) {   /* empty segment */
  776.                 vsold->vs_next = vseg->vs_next;     /* unlink segment */
  777.                 vscount--;                          /* adjust tallies */
  778.                 total -= sizeof(VSEGMENT)-sizeof(LVAL FAR *)+
  779.                     (unsigned)vseg->vs_top - (unsigned)vseg->vs_free;
  780.                 MFREE(vseg);                        /* free segment */
  781.                 vseg = vsold;                       /* last becomes current */
  782.             }
  783.  
  784.         /* make the first vector segment current */
  785.         if ((vscurrent = vsegments) != NULL) {
  786.             vfree = vscurrent->vs_free;
  787.             vtop = vscurrent->vs_top;
  788.         }
  789.     }
  790. }
  791.  
  792. /* compact_vector - compact a vector segment */
  793. LOCAL VOID NEAR compact_vector(vseg)
  794.   VSEGMENT FAR *vseg;
  795. {
  796.     LVAL FAR *vdata, FAR *vnext, FAR *vfree,vector;
  797.     unsigned vsize;
  798.  
  799.     vdata = vnext = &vseg->vs_data[0];
  800.     vfree = vseg->vs_free;
  801.     while (vdata < vfree) {
  802.         vector = *vdata;
  803.         if ((vector->n_type & TYPEFIELD) == STRING)
  804.             vsize = btow_size(vector->n_strlen+1) + 1;
  805.         else
  806.             vsize = vector->n_vsize + 1;
  807.         if (vector->n_type & MARK) {
  808.             if (vdata != vnext) {
  809.                 vector->n_vdata = vnext + 1;
  810.                 MEMCPY(vnext, vdata, vsize * (unsigned)sizeof(LVAL));
  811.             }
  812.             vnext += vsize;
  813.         }
  814.         vdata += vsize;
  815.     }
  816.     vseg->vs_free = vnext;
  817. }
  818.  
  819. /* sweep - sweep all unmarked nodes and add them to the free list */
  820. LOCAL VOID NEAR sweep()
  821. {
  822.     SEGMENT FAR *seg;
  823.     LVAL p;
  824.     int n;
  825.  
  826.     /* empty the free list */
  827.     fnodes = NIL;
  828.     nfree = 0L;
  829.  
  830.     /* add all unmarked nodes */
  831.     for (seg = segs; seg != NULL; seg = seg->sg_next) {
  832.         if (seg == fixseg || seg == charseg) {
  833.             /* remove marks from segments */
  834.             p = &seg->sg_nodes[0];
  835.             for (n = seg->sg_size; --n >= 0;)
  836.                 (p++)->n_type &= ~MARK;
  837.             continue;
  838.         }
  839.         p = &seg->sg_nodes[0];
  840.         for (n = seg->sg_size; --n >= 0;)
  841.             if (p->n_type & MARK)
  842.                 (p++)->n_type &= ~MARK;
  843.             else {
  844.                 if (((ntype(p)&TYPEFIELD) == STREAM) 
  845.                     && getfile(p) != CLOSED
  846.                     && getfile(p) != STDIN
  847.                     && getfile(p) != STDOUT
  848.                     && getfile(p) != CONSOLE)/* taa fix - dont close stdio */
  849.                     OSCLOSE(getfile(p));
  850.                 p->n_type = FREE;
  851.                 rplaca(p,NIL);
  852.                 rplacd(p,fnodes);
  853.                 fnodes = p++;
  854.                 nfree++;
  855.             }
  856.     }
  857. }
  858.  
  859. /* addseg - add a segment to the available memory */
  860. LOCAL int NEAR addseg()
  861. {
  862.     SEGMENT FAR *newseg;
  863.     LVAL p;
  864.     int n;
  865.  
  866.     /* allocate the new segment */
  867.     if (anodes == 0 || (newseg = newsegment(anodes)) == NULL)
  868.         return (FALSE);
  869.  
  870.     /* add each new node to the free list */
  871.     p = &newseg->sg_nodes[0];
  872.     for (n = anodes; --n >= 0; ++p) {
  873.         rplacd(p,fnodes);
  874.         fnodes = p;
  875.     }
  876.  
  877.     /* return successfully */
  878.     return (TRUE);
  879. }
  880.  
  881. /* newsegment - create a new segment (only called here and in xlimage.c) */
  882. SEGMENT FAR *newsegment(n)
  883.   int n;
  884. {
  885.     SEGMENT FAR *newseg;
  886.  
  887.     /* allocate the new segment */
  888.     if ((newseg = (SEGMENT FAR *)CALLOC(1,segsize(n))) == NULL)
  889.         return (NULL);
  890.  
  891.     /* initialize the new segment */
  892.     newseg->sg_size = n;
  893.     newseg->sg_next = NULL;
  894.     if (segs != NULL)
  895.         lastseg->sg_next = newseg;
  896.     else
  897.         segs = newseg;
  898.     lastseg = newseg;
  899.  
  900.     /* update the statistics */
  901.     total += (long)segsize(n);
  902.     nnodes += (long)n;
  903.     nfree += (long)n;
  904.     ++nsegs;
  905.  
  906.     /* return the new segment */
  907.     return (newseg);
  908. }
  909.  
  910. /* stats - print memory statistics */
  911. #ifdef ANSI
  912. static void NEAR stats(void)
  913. #else
  914. LOCAL VOID stats()
  915. #endif
  916. {
  917.     sprintf(buf,"Nodes:        %ld\n",nnodes); stdputstr(buf);
  918.     sprintf(buf,"Free nodes:   %ld\n",nfree);  stdputstr(buf);
  919.     sprintf(buf,"Segments:     %d\n",nsegs);   stdputstr(buf);
  920.     sprintf(buf,"Vector nodes: %ld\n",getvused());     stdputstr(buf);
  921.     sprintf(buf,"Vector free:  %ld\n",vsfree); stdputstr(buf);
  922.     sprintf(buf,"Vector segs:  %d\n",vscount); stdputstr(buf);
  923.     sprintf(buf,"Allocate:     %d\n",anodes);  stdputstr(buf);
  924.     sprintf(buf,"Vec Allocate: %d\n",vnodes);  stdputstr(buf);
  925.     sprintf(buf,"Total:        %ld\n",total);  stdputstr(buf);
  926.     sprintf(buf,"Collections:  %ld\n",gccalls); stdputstr(buf);
  927. }
  928.  
  929. /* xgc - xlisp function to force garbage collection */
  930. LVAL xgc()
  931. {
  932.     /* make sure there aren't any arguments */
  933.     xllastarg();
  934.  
  935.     /* garbage collect */
  936.     gc();
  937.  
  938.     /* return nil */
  939.     return (NIL);
  940. }
  941.  
  942. /* xexpand - xlisp function to force memory expansion */
  943. LVAL xexpand()
  944. {
  945.     LVAL num;
  946.     FIXTYPE n,i;
  947.  
  948.     /* get the new number to allocate */
  949.     if (moreargs()) {
  950.         num = xlgafixnum();
  951.         n = getfixnum(num);
  952.         xllastarg();
  953.     }
  954.     else
  955.         n = 1;
  956.  
  957.     /* allocate more segments */
  958.     for (i = 0; i < n; i++)
  959.         if (!addseg())
  960.             break;
  961.  
  962.     /* return the number of segments added */
  963.     return (cvfixnum((FIXTYPE)i));
  964. }
  965.  
  966. /* xalloc - xlisp function to set the number of nodes to allocate */
  967. LVAL xalloc()
  968. {
  969.     FIXTYPE n,vn;   /* TAA MOD -- prevent overflow */
  970.     int oldn;
  971.  
  972.     /* get the new number to allocate */
  973.     n = getfixnum(xlgafixnum());
  974.  
  975.     if (moreargs()) {   /* vector allocation */
  976.         vn = getfixnum(xlgafixnum());
  977.         xllastarg();
  978.         /* clip to reasonable values*/
  979.         if (vn > (long)MAXVLEN-sizeof(VSEGMENT)/sizeof(LVAL)) 
  980.             vn = MAXVLEN-sizeof(VSEGMENT)/sizeof(LVAL); 
  981.         else if (vn < 1000) vn = 1000;
  982.         vnodes = (int)vn;
  983.     }
  984.  
  985.     /* Place limits on argument by clipping to reasonable values  TAA MOD */
  986.     if (n > ((long)MAXSLEN - sizeof(SEGMENT))/sizeof(struct node)) 
  987.         n = ((long)MAXSLEN - sizeof(SEGMENT))/sizeof(struct node);
  988.     else if (n < 1000) 
  989.         n = 1000;   /* arbitrary */
  990.  
  991.     /* set the new number of nodes to allocate */
  992.     oldn = anodes;
  993.     anodes = (int)n;
  994.  
  995.     /* return the old number */
  996.     return (cvfixnum((FIXTYPE)oldn));
  997. }
  998.  
  999. /* xmem - xlisp function to print memory statistics */
  1000. LVAL xmem()
  1001. {
  1002.     /* allow one argument for compatiblity with common lisp */
  1003.     if (xlargc > 1) xltoomany();    /* TAA Mod */
  1004.  
  1005.     /* print the statistics */
  1006.     stats();
  1007.  
  1008.     /* return nil */
  1009.     return (NIL);
  1010. }
  1011.  
  1012. #ifdef SAVERESTORE
  1013. /* xsave - save the memory image */
  1014. LVAL xsave()
  1015. {
  1016. #ifdef MEDMEM
  1017.     char name[STRMAX];
  1018. #else
  1019.     char *name;
  1020. #endif
  1021.  
  1022.     /* get the file name */
  1023. #ifdef MEDMEM
  1024.     _fstrncpy(name, getstring(xlgetfname()), STRMAX);
  1025.     name[STRMAX-1] = '\0';
  1026. #else
  1027.     name = getstring(xlgetfname());
  1028. #endif
  1029.     xllastarg();
  1030.  
  1031.     /* save the memory image */
  1032.     return (xlisave(name) ? true : NIL);
  1033. }
  1034.  
  1035. /* xrestore - restore a saved memory image */
  1036. LVAL xrestore()
  1037. {
  1038.     extern jmp_buf top_level;
  1039. #ifdef MEDMEM
  1040.     char name[STRMAX];
  1041. #else
  1042.     char *name;
  1043. #endif
  1044.  
  1045.     /* get the file name */
  1046. #ifdef MEDMEM
  1047.     _fstrncpy(name, getstring(xlgetfname()), STRMAX);
  1048.     name[STRMAX-1] = '\0';
  1049. #else
  1050.     name = getstring(xlgetfname());
  1051. #endif
  1052.     xllastarg();
  1053.  
  1054.     /* restore the saved memory image */
  1055.     if (!xlirestore(name))
  1056.         return (NIL);
  1057.  
  1058.     /* return directly to the top level */
  1059.     dbgputstr("[ returning to the top level ]\n");  /* TAA MOD --was std out*/
  1060.     longjmp(top_level,1);
  1061.     return (NIL);   /* never executed, but avoids warning message */
  1062. }
  1063. #endif
  1064.  
  1065. #ifdef COMPLX
  1066. /* From XLISP-STAT, Copyright (c) 1988 Luke Tierney */
  1067.  
  1068. LVAL newicomplex(real, imag)
  1069.         FIXTYPE real, imag;
  1070. {
  1071.   LVAL val;
  1072.   
  1073.   if (imag == 0) val = cvfixnum(real);
  1074.   else {
  1075.     xlsave1(val);
  1076.     val = newvector(2);
  1077.     val->n_type = COMPLEX;
  1078.     setelement(val, 0, cvfixnum(real));
  1079.     setelement(val, 1, cvfixnum(imag));
  1080.     xlpop();
  1081.   }
  1082.   return(val);
  1083. }
  1084.  
  1085. LVAL newdcomplex(real, imag)
  1086.         double real, imag;
  1087. {
  1088.   LVAL val;
  1089.   
  1090.   xlsave1(val);
  1091.   val = newvector(2);
  1092.   val->n_type = COMPLEX;
  1093.   setelement(val, 0, cvflonum((FLOTYPE) real));
  1094.   setelement(val, 1, cvflonum((FLOTYPE) imag));
  1095.   xlpop();
  1096.   return(val);
  1097. }
  1098.  
  1099. /* newcomplex - allocate and initialize a new object */
  1100. LVAL newcomplex(real,imag)
  1101.   LVAL real,imag;
  1102. {
  1103.   if (fixp(real) && fixp(imag))
  1104.     return(newicomplex(getfixnum(real), getfixnum(imag)));
  1105.   else
  1106.     return(newdcomplex(makefloat(real), makefloat(imag)));
  1107. }
  1108.  
  1109. #endif
  1110.